home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / paramlst.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  133 lines
  1. ;;; "paramlst.scm" passing parameters by name.
  2. ; Copyright 1995, 1996, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Format of arity-spec: (name predicate conversion)
  21.  
  22. (require 'common-list-functions)
  23.  
  24. (define arity->arity-spec
  25.   (let ((table
  26.      `((nary
  27.         ,(lambda (a) #t)
  28.         ,identity)
  29.        (nary1
  30.         ,(lambda (a) (not (null? a)))
  31.         ,identity)
  32.        (single
  33.         ,(lambda (a) (and (pair? a) (null? (cdr a))))
  34.         ,car)
  35.        (optional
  36.         ,(lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))
  37.         ,identity)
  38.        (boolean
  39.         ,(lambda (a)
  40.            (or (null? a)
  41.            (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
  42.         ,(lambda (a) (if (null? a) #f (car a)))))))
  43.     (lambda (arity)
  44.       (assq arity table))))
  45.  
  46. (define (fill-empty-parameters defaulters parameter-list)
  47.   (map (lambda (defaulter parameter)
  48.      (cond ((null? (cdr parameter))
  49.         (cons (car parameter)
  50.               (if defaulter (defaulter parameter-list) '())))
  51.            (else parameter)))
  52.        defaulters parameter-list))
  53.  
  54. (define (check-parameters checks parameter-list)
  55.   (and (every (lambda (check parameter)
  56.         (every
  57.          (lambda (p)
  58.            (let ((good? (not (and check (not (check p))))))
  59.              (if (not good?)
  60.              (slib:warn
  61.               (car parameter) "parameter is wrong type: " p))
  62.              good?))
  63.          (cdr parameter)))
  64.           checks parameter-list)
  65.        parameter-list))
  66.  
  67. (define (check-arities arity-specs parameter-list)
  68.   (and (every identity arity-specs)
  69.        (every
  70.     (lambda (arity-spec param)
  71.       ((cadr arity-spec) (cdr param)))
  72.     arity-specs parameter-list)))
  73.  
  74. (define (parameter-list->arglist positions arities parameter-list)
  75.   (and (= (length arities) (length positions) (length parameter-list))
  76.        (let ((arity-specs (map arity->arity-spec arities))
  77.          (ans (make-vector (length positions) #f)))
  78.      (and (check-arities arity-specs parameter-list)
  79.           (for-each
  80.            (lambda (pos arity-spec param)
  81.          (vector-set! ans (+ -1 pos)
  82.                   ((caddr arity-spec) (cdr param))))
  83.            positions arity-specs parameter-list)
  84.           (vector->list ans)))))
  85.  
  86. (define (make-parameter-list parameter-names)
  87.   (map list parameter-names))
  88.  
  89. (define (parameter-list-ref parameter-list i)
  90.   (let ((ans (assoc i parameter-list)))
  91.     (and ans (cdr ans))))
  92.  
  93. (define (parameter-list-expand expanders parms)
  94.   (do ((lens (map length parms) (map length parms))
  95.        (olens '() lens))
  96.       ((equal? lens olens))
  97.     (for-each (lambda (expander parm)
  98.         (cond
  99.          (expander
  100.           (for-each
  101.            (lambda (news)
  102.              (cond ((adjoin-parameters! parms news))
  103.                (else (slib:error
  104.                   "expanded feature unknown: " news))))
  105.            (apply append
  106.               (map (lambda (p)
  107.                  (cond ((expander p))
  108.                        ((not '()) '())
  109.                        (else (slib:error
  110.                           "couldn't expand feature: " p))))
  111.                    (cdr parm)))))))
  112.           expanders
  113.           parms)))
  114.  
  115. (define (adjoin-parameters! parameter-list . parameters)
  116.   (let ((apairs (map (lambda (param)
  117.                (cond ((pair? param)
  118.                   (assoc (car param) parameter-list))
  119.                  (else (assoc param parameter-list))))
  120.              parameters)))
  121.     (and (every identity apairs)    ;same as APPLY AND?
  122.      (for-each
  123.       (lambda (apair param)
  124.         (cond ((pair? param)
  125.            (for-each (lambda (o)
  126.                    (if (not (member o (cdr apair)))
  127.                    (set-cdr! apair (cons o (cdr apair)))))
  128.                  (cdr param)))
  129.           (else (if (not (memv #t (cdr apair)))
  130.                 (set-cdr! apair (cons #t (cdr apair)))))))
  131.       apairs parameters)
  132.      parameter-list)))
  133.